home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1993 / MacHack 1993.toast / MacHack™ 1987-1992 / MacHack™ '87 / Source ƒ / XLISP ƒ / XLISP 1.7 C SRCS / xlisp.h < prev    next >
Encoding:
C/C++ Source or Header  |  1986-07-07  |  9.5 KB  |  340 lines  |  [TEXT/????]
  1. /* xlisp - a small subset of lisp */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. /* system specific definitions */
  7. #define MEGAMAX
  8.  
  9. #include <stdio.h>
  10. #include <ctype.h>
  11. #ifndef MEGAMAX
  12. #include <setjmp.h>
  13. #endif
  14.  
  15. /* NNODES    number of nodes to allocate in each request (1000) */
  16. /* TDEPTH    trace stack depth (500) */
  17. /* EDEPTH    evaluation stack depth (2000) */
  18. /* FORWARD    type of a forward declaration () */
  19. /* LOCAL    type of a local function (static) */
  20. /* AFMT        printf format for addresses ("%x") */
  21. /* FIXNUM    data type for fixed point numbers (long) */
  22. /* ITYPE    fixed point input conversion routine type (long atol()) */
  23. /* ICNV        fixed point input conversion routine (atol) */
  24. /* IFMT        printf format for fixed point numbers ("%ld") */
  25. /* FLONUM    data type for floating point numbers (float) */
  26. /* SYSTEM    enable the control-d command */
  27.  
  28. /* for the MPW compiler */
  29. #ifdef MPW
  30. #endif
  31.  
  32. /* for the MegaMax compiler */
  33. #ifdef MEGAMAX
  34. #define LOCAL
  35. #define AFMT        "%lx"
  36. #endif
  37.  
  38. /* for the AZTEC C compiler - small model */
  39. #ifdef AZTEC_SM
  40. #define SYSTEM
  41. #define NIL        (void *)0
  42. #endif
  43.  
  44. /* for the AZTEC C compiler - large model */
  45. #ifdef AZTEC_LM
  46. #define SYSTEM
  47. #define NNODES        2000
  48. #define AFMT        "%lx"
  49. #define FLONUM        double
  50. #define NIL        (void *)0
  51. #endif
  52.  
  53. /* for the Digital Research C compiler (Atari ST) */
  54. #ifdef DR
  55. #define LOCAL
  56. #define AFMT        "%lx"
  57. #define FLONUM        double
  58. #undef NULL
  59. #define NULL        0L
  60. #endif
  61.  
  62. /* default important definitions */
  63. #ifndef NNODES
  64. #define NNODES        1000
  65. #endif
  66. #ifndef TDEPTH
  67. #define TDEPTH        500
  68. #endif
  69. #ifndef EDEPTH
  70. #define EDEPTH        2000
  71. #endif
  72. #ifndef FORWARD
  73. #define FORWARD
  74. #endif
  75. #ifndef LOCAL
  76. #define LOCAL        static
  77. #endif
  78. #ifndef AFMT
  79. #define AFMT        "%x"
  80. #endif
  81. #ifndef FIXNUM
  82. #define FIXNUM        long
  83. #endif
  84. #ifndef ITYPE
  85. #define ITYPE        long atol()
  86. #endif
  87. #ifndef ICNV
  88. #define ICNV(n)        atol(n)
  89. #endif
  90. #ifndef IFMT
  91. #define IFMT        "%ld"
  92. #endif
  93. #ifndef FLONUM
  94. #define FLONUM        float
  95. #endif
  96.  
  97. /* useful definitions */
  98. #define TRUE    1
  99. #define FALSE    0
  100. #ifndef NIL
  101. #define NIL    (NODE *)0
  102. #endif
  103.  
  104. /* program limits */
  105. #define STRMAX        100        /* maximum length of a string constant */
  106. #define HSIZE        199        /* symbol hash table size */
  107. #define SAMPLE        100        /* control character sample rate */
  108.     
  109. /* node types */
  110. #define FREE    0
  111. #define SUBR    1
  112. #define FSUBR    2
  113. #define LIST    3
  114. #define SYM    4
  115. #define INT    5
  116. #define STR    6
  117. #define OBJ    7
  118. #define FPTR    8
  119. #define FLOAT    9
  120. #define VECT    10
  121.  
  122. /* node flags */
  123. #define MARK    1
  124. #define LEFT    2
  125.  
  126. /* string types */
  127. #define DYNAMIC    0
  128. #define STATIC    1
  129.  
  130. /* new node access macros */
  131. #define ntype(x)    ((x)->n_type)
  132.  
  133. /* macros to protect node pointers */
  134. #define xlstkcheck(n)    {if (xlstack - (n) < xlstkbase) xlstkoverflow();}
  135. #define xlsave(n)    {*--xlstack = &n; n = NIL;}
  136. #define xlprotect(n)    {*--xlstack = &n;}
  137.  
  138. /* check the stack and protect a single pointer */
  139. #define xlsave1(n)    {if (xlstack <= xlstkbase) xlstkoverflow();\
  140.                          *--xlstack = &n; n = NIL;}
  141.  
  142. /* type predicates */
  143. #define atom(x)        ((x) == NIL || (x)->n_type != LIST)
  144. #define null(x)        ((x) == NIL)
  145. #define listp(x)    ((x) == NIL || (x)->n_type == LIST)
  146. #define consp(x)    ((x) && (x)->n_type == LIST)
  147. #define subrp(x)    ((x) && (x)->n_type == SUBR)
  148. #define fsubrp(x)    ((x) && (x)->n_type == FSUBR)
  149. #define stringp(x)    ((x) && (x)->n_type == STR)
  150. #define symbolp(x)    ((x) && (x)->n_type == SYM)
  151. #define filep(x)    ((x) && (x)->n_type == FPTR)
  152. #define objectp(x)    ((x) && (x)->n_type == OBJ)
  153. #define fixp(x)        ((x) && (x)->n_type == INT)
  154. #define floatp(x)    ((x) && (x)->n_type == FLOAT)
  155. #define vectorp(x)    ((x) && (x)->n_type == VECT)
  156.  
  157. /* cons access macros */
  158. #define car(x)        ((x)->n_car)
  159. #define cdr(x)        ((x)->n_cdr)
  160. #define consa(x)    cons(x,NIL)
  161. #define consd(x)    cons(NIL,x)
  162. #define rplaca(x,y)    ((x)->n_car = (y))
  163. #define rplacd(x,y)    ((x)->n_cdr = (y))
  164.  
  165. /* symbol access macros */
  166. #define getvalue(x)    ((x)->n_symvalue)
  167. #define setvalue(x,v)    ((x)->n_symvalue = (v))
  168. #define getplist(x)    ((x)->n_symplist->n_cdr)
  169. #define setplist(x,v)    ((x)->n_symplist->n_cdr = (v))
  170. #define getpname(x)    ((x)->n_symplist->n_car)
  171.  
  172. /* vector access macros */
  173. #define getsize(x)    ((x)->n_vsize)
  174. #define getelement(x,i)    ((x)->n_vdata[i])
  175. #define setelement(x,i,v) ((x)->n_vdata[i] = (v))
  176.  
  177. /* object access macros */
  178. #define getclass(x)    ((x)->n_vdata[0])
  179. #define getivar(x,i)    ((x)->n_vdata[i+1])
  180. #define setivar(x,i,v)    ((x)->n_vdata[i+1] = (v))
  181.  
  182. /* subr/fsubr access macros */
  183. #define getsubr(x)    ((x)->n_subr)
  184.  
  185. /* fixnum/flonum access macros */
  186. #define getfixnum(x)    ((x)->n_int)
  187. #define getflonum(x)    ((x)->n_float)
  188.  
  189. /* string access macros */
  190. #define getstring(x)    ((x)->n_str)
  191. #define setstring(x,v)    ((x)->n_str = (v))
  192.  
  193. /* file access macros */
  194. #define getfile(x)    ((x)->n_fp)
  195. #define setfile(x,v)    ((x)->n_fp = (v))
  196. #define getsavech(x)    ((x)->n_savech)
  197. #define setsavech(x,v)    ((x)->n_savech = (v))
  198.  
  199. /* macro to check for the end of the argument list */
  200. #define xllastarg(args)    if (args) xltoomany(args)
  201.  
  202. /* symbol node */
  203. #define n_symplist    n_info.n_xsym.xsy_plist
  204. #define n_symvalue    n_info.n_xsym.xsy_value
  205.  
  206. /* subr/fsubr node */
  207. #define n_subr        n_info.n_xsubr.xsu_subr
  208.  
  209. /* list node */
  210. #define n_car        n_info.n_xlist.xl_car
  211. #define n_cdr        n_info.n_xlist.xl_cdr
  212.  
  213. /* integer node */
  214. #define n_int        n_info.n_xint.xi_int
  215.  
  216. /* float node */
  217. #define n_float        n_info.n_xfloat.xf_float
  218.  
  219. /* string node */
  220. #define n_str        n_info.n_xstr.xst_str
  221. #define n_strtype    n_info.n_xstr.xst_type
  222.  
  223. /* file pointer node */
  224. #define n_fp        n_info.n_xfptr.xf_fp
  225. #define n_savech    n_info.n_xfptr.xf_savech
  226.  
  227. /* vector/object node */
  228. #define n_vsize        n_info.n_xvect.xv_size
  229. #define n_vdata        n_info.n_xvect.xv_data
  230.  
  231. /* node structure */
  232. typedef struct node {
  233.     char n_type;        /* type of node */
  234.     char n_flags;        /* flag bits */
  235.     union {            /* value */
  236.     struct xsym {        /* symbol node */
  237.         struct node *xsy_plist;    /* symbol plist - (name . plist) */
  238.         struct node *xsy_value;    /* the current value */
  239.     } n_xsym;
  240.     struct xsubr {        /* subr/fsubr node */
  241.         struct node *(*xsu_subr)();    /* pointer to an internal routine */
  242.     } n_xsubr;
  243.     struct xlist {        /* list node (cons) */
  244.         struct node *xl_car;    /* the car pointer */
  245.         struct node *xl_cdr;    /* the cdr pointer */
  246.     } n_xlist;
  247.     struct xint {        /* integer node */
  248.         FIXNUM xi_int;        /* integer value */
  249.     } n_xint;
  250.     struct xfloat {        /* float node */
  251.         FLONUM xf_float;        /* float value */
  252.     } n_xfloat;
  253.     struct xstr {        /* string node */
  254.         int xst_type;        /* string type */
  255.         char *xst_str;        /* string pointer */
  256.     } n_xstr;
  257.     struct xfptr {        /* file pointer node */
  258.         FILE *xf_fp;        /* the file pointer */
  259.         int xf_savech;        /* lookahead character for input files */
  260.     } n_xfptr;
  261.     struct xvect {        /* vector node */
  262.         int xv_size;        /* vector size */
  263.         struct node **xv_data;    /* vector data */
  264.     } n_xvect;
  265.     } n_info;
  266. } NODE;
  267.  
  268. /* execution context flags */
  269. #define CF_GO        1
  270. #define CF_RETURN    2
  271. #define CF_THROW    4
  272. #define CF_ERROR    8
  273. #define CF_CLEANUP    16
  274. #define CF_CONTINUE    32
  275. #define CF_TOPLEVEL    64
  276.  
  277. /* execution context */
  278. typedef struct context {
  279.     int c_flags;            /* context type flags */
  280.     struct node *c_expr;        /* expression (type dependant) */
  281.     jmp_buf c_jmpbuf;            /* longjmp context */
  282.     struct context *c_xlcontext;    /* old value of xlcontext */
  283.     struct node ***c_xlstack;        /* old value of xlstack */
  284.     struct node *c_xlenv;        /* old value of xlenv */
  285.     int c_xltrace;            /* old value of xltrace */
  286. } CONTEXT;
  287.  
  288. /* function table entry structure */
  289. struct fdef {
  290.     char *f_name;            /* function name */
  291.     int f_type;                /* function type SUBR/FSUBR */
  292.     struct node *(*f_fcn)();        /* function code */
  293. };
  294.  
  295. /* memory segment structure definition */
  296. struct segment {
  297.     int sg_size;
  298.     struct segment *sg_next;
  299.     struct node sg_nodes[1];
  300. };
  301.  
  302. /* external variables */
  303. extern struct node ***xlstktop;        /* top of the evaluation stack */
  304. extern struct node ***xlstkbase;    /* base of the evaluation stack */
  305. extern struct node ***xlstack;        /* evaluation stack pointer */
  306.  
  307. /* external procedure declarations */
  308. extern struct node *xleval();        /* evaluate an expression */
  309. extern struct node *xlapply();        /* apply a function to arguments */
  310. extern struct node *xlevlist();        /* evaluate a list of arguments */
  311. extern struct node *xlarg();        /* fetch an argument */
  312. extern struct node *xlevarg();        /* fetch and evaluate an argument */
  313. extern struct node *xlmatch();        /* fetch an typed argument */
  314. extern struct node *xlevmatch();    /* fetch and evaluate a typed arg */
  315. extern struct node *xlgetfile();    /* fetch a file/stream argument */
  316. extern struct node *xlsend();        /* send a message to an object */
  317. extern struct node *xlenter();        /* enter a symbol */
  318. extern struct node *xlsenter();        /* enter a symbol with a static pname */
  319. extern struct node *xlmakesym();    /* make an uninterned symbol */
  320. extern struct node *xlframe();        /* establish a new environment frame */
  321. extern struct node *xlgetvalue();    /* get value of a symbol */
  322.  
  323. extern struct node *cons();        /* (cons x y) */
  324.  
  325. extern struct node *cvsymbol();        /* convert a string to a symbol */
  326. extern struct node *cvcsymbol();    /* (same but constant string) */
  327. extern struct node *cvstring();        /* convert a string */
  328. extern struct node *cvcstring();    /* (same but constant string) */
  329. extern struct node *cvfile();        /* convert a FILE * to a file */
  330. extern struct node *cvsubr();        /* convert a function to a subr/fsubr */
  331. extern struct node *cvfixnum();        /* convert a fixnum */
  332. extern struct node *cvflonum();        /* convert a flonum */
  333.  
  334. extern struct node *newstring();    /* create a new string */
  335. extern struct node *newvector();    /* create a new vector */
  336. extern struct node *newobject();    /* create a new object */
  337.  
  338. extern struct node *xlgetprop();    /* get the value of a property */
  339.  
  340.